{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Score
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Relative pitch (and relative duration) monad.
--
--------------------------------------------------------------------------------


module Lirio.Score
  (

    Env(..)
  , Score
  , runScore
  , execScore

  , withScore

  , asks
  , local

  -- * wl-pprint combinators lifted to the Score monad
  , genDoc
  , genConcat
  , renderDoc80

  , (<+>)
  , (<$>)

  
  , text 
  , string
  , char
  , int 

  , enclose
  , nest

  , braces
  , dangles
  , dquotes

  , equals
  , bool
  , block

  , Var
  , vardef
  , usevar

  ) where

import Lirio.Base.Overloading
import Lirio.Base.Pitch
-- import qualified Lirio.PrimLilyPond as P

import qualified Text.PrettyPrint.Leijen as PP          -- package: wl-pprint
import Text.PrettyPrint.Leijen ( Doc )

import Control.Applicative hiding ( empty, (<$>) )
import Control.Monad ( void )
import Data.Monoid 



newtype Env = Env { relative_pitch :: Pitch }

-- should we have
--
-- > newtype GenScore a = ...
--
-- > type Score = GenScore ()
--


-- | Score - reader + writer.
--
newtype Score a = Score { getScore :: Env -> (a,Doc) }

instance Functor Score where
  fmap f ma = Score $ \r -> let (a,w) = getScore ma r in (f a, w)

instance Applicative Score where
  pure a    = Score $ \_ -> (a,PP.empty)
  mf <*> ma = Score $ \r -> let (f,w1) = getScore mf r
                                (a,w2) = getScore ma r 
                            in (f a, w1 PP.<> w2)

instance Monad Score where
  return   = pure
  ma >>= k = Score $ \r -> let (a,w1) = getScore ma r
                               (b,w2) = getScore (k a) r
                           in (b, w1 PP.<> w2)

instance Monoid a => Monoid (Score a) where
  mempty = pure mempty
  ma `mappend` mb = Score $ \r -> let (a,w1) = getScore ma r 
                                      (b,w2) = getScore mb r
                                  in (a `mappend` b, w1 PP.<> w2)



instance HasCommandM Score where
  command = text . ('\\':)

instance HasNewlineM Score where
  newline = genDoc PP.line



runScore :: Score a -> (a,Doc)
runScore ma = getScore ma (Env middle_c)

execScore :: Score a -> Doc
execScore = snd . runScore


withScore :: (Env -> (a,Doc)) -> Score a
withScore fn = Score $ \r -> fn r


asks :: (Env -> a) -> Score a 
asks f = Score $ \r -> (f r, PP.empty)

local :: (Env -> Env) -> Score a -> Score a
local f ma = Score $ \r -> getScore ma (f r)



mapW :: (Doc -> Doc) -> Score a -> Score a
mapW fn ma = Score $ \r -> let (a,w1) = getScore ma r
                           in (a, fn w1)

--------------------------------------------------------------------------------
-- Variations of wl-pprint combinators


genDoc :: Doc -> Score ()
genDoc d = Score $ \_ -> ((), d)

genConcat :: Monoid a 
          => (Doc -> Doc -> Doc) -> Score a -> Score a -> Score a
genConcat op ma mb = Score $ \r -> let (a,w1) = getScore ma r
                                       (b,w2) = getScore mb r
                                   in (a `mappend` b, w1 `op` w2)



infixr 6 <+>

(<+>) :: Monoid a => Score a -> Score a -> Score a
(<+>) = genConcat (PP.<+>)

infixr 5 <$>

(<$>) :: Monoid a => Score a -> Score a -> Score a
(<$>) = genConcat (PP.<$>)


renderDoc80 :: PP.Doc -> String
renderDoc80 d = PP.displayS (PP.renderPretty 0.8 80 d) ""


-- Primitive type docs

-- | No newlines or tabs...
--
text :: String -> Score ()
text = genDoc . PP.text

string :: String -> Score ()
string = genDoc . PP.string

int :: Int -> Score ()
int = genDoc . PP.int


char :: Char -> Score ()
char = genDoc . PP.char


bool :: Bool -> Score ()
bool True  = text "##t"
bool False = text "##f"




enclose :: Doc -> Doc -> Score a -> Score a
enclose l r ma = genDoc l *> ma <* genDoc r

nest :: Int -> Score a -> Score a
nest i = mapW (PP.nest i)
                    

braces :: Score a -> Score a
braces = enclose (PP.char '{') (PP.char '}')

dangles :: Score a -> Score a
dangles = enclose (PP.text "<<") (PP.text ">>")


dquotes :: Score a -> Score a
dquotes = enclose (PP.char '"') (PP.char '"')


equals :: Score ()
equals = char '='


-- | Print a block with idiomatic nesting.
--
block :: Score a -> Score ()
block ma = nest 2 (char '{' <$> void ma) <$> char '}'


newtype Var = Var { getVar :: String }

vardef :: String -> Score a -> Score Var
vardef name body = Var name <$ sdoc
  where
    sdoc = text name <+> equals <+> void (body)

usevar :: Var -> Score ()
usevar = command . getVar